%{
  open Ast
  open Parseutils
  open Errors
%}

%token <string> IDENT
%token <int> INT
%token PLUS
%token MINUS
%token TIMES
%token DIV
%token MOD
%token LPAREN
%token RPAREN
%token SEMICOLON
%token COLON
%token COMMA
%token ASSIGNMENT
%token IF
%token THEN
%token ELSE
%token BEGIN
%token END
%token WHILE
%token DO
%token LE
%token LEQ
%token EQ
%token NEQ
%token GE
%token GEQ
%token TRUE
%token FALSE
%token AND
%token OR
%token EOF
%token VAR
%token INTEGER
%token BOOLEAN
%token VOID
%token FORWARD
%token NOT
%token BEGINREXPR
%token ENDREXPR
%token LFUN
%token RFUN
%token ENDF
%token LRECORD
%token RRECORD
%token ENDRECORD
%token MEMBER
%token NEW
%token NIL

%left LE LEQ EQ NEQ GE GEQ
%left OR
%left AND
%left PLUS MINUS 
%left TIMES DIV MOD
%nonassoc UMINUS
%nonassoc NOT
%left MEMBER

%start progdecl
%type <Ast.mpprog_t> progdecl


%%
progdecl:
| progrecorddecl progvardecl progfundecl progfundefl statement EOF { new_mpprog $2 $1 $3 $4 $5 }
;

progvardecl:
| vardecl { 
    if (duplicates $1) then 
      raise Name_clash1; 
    Types.open_globalenv $1;
    $1 
}
;

progrecorddecl:
| recorddecl {
    List.iter (             
      fun record ->
        List.iter (
          fun (fname, ftype) -> match ftype with
            | Record rname when not (Types.record_declared rname)
                -> raise UnknownType_error;
            | _ -> ()
        ) record#members
    ) $1;
    $1
  }
;

progfundecl:
| fundecl { $1 }
;

progfundefl:
| fundefl { $1 }
;

vardecl:
| { [] }
| VAR varlist SEMICOLON { $2 }
;

recorddecl:
| { [] }
| mp_record recorddecl { $1::$2 }
;

mp_record:
| LRECORD IDENT RRECORD memberdecl ENDRECORD {
    Types.declare_record ($2, $4);
    new_mprecord $2 $4
}
;

varlist: 
| { [] }
| IDENT COLON typedecl varlist1 {
    if $3 = Void then
      raise (Void_declared_error $1);
    ($1,$3)::$4
}
;

varlist1:
| { [] }
| COMMA varlist { $2 }
;

typedecl:
| INTEGER { Integer }
| BOOLEAN { Boolean }
| VOID { Void }
| IDENT { 
    Record $1
}
;

memberdecl:
| { [] }
| varlist SEMICOLON { $1 }
;

fundecl:
| { [] }
| FORWARD fun_header_decl fundecl { $2::$3 }
;

fun_header_decl:
| LFUN IDENT RFUN LPAREN varlist RPAREN COLON typedecl {

    (* name: $2, parms: $5, ret type: $8 *)

    Types.declare_fun ($2, (List.map snd $5, $8));
    ($2, (List.map snd $5, $8))
}
;

fundefl:
| { [] }
| mp_function fundefl { $1::$2 }
; 

mp_function: 
| fun_header statement ENDF { 
    let (name,parameters,locvars,rettype) = $1 in
      Types.close_localenv ();
      new_mpfun name parameters locvars $2 rettype
}
;

fun_header:
| LFUN IDENT RFUN LPAREN varlist RPAREN COLON typedecl vardecl { 

    (* name: $2, parms: $5, ret type: $8, locals: $9 *)

    let localenv = $5 @ $9 in
    let localnames = List.map fst localenv in
      if (duplicates localenv) or (List.mem $2 localnames) then 
	raise (Name_clash3 $2);
      Types.define_fun ($2, (List.map snd $5, $8));
      Types.open_localenv (($2,$8)::localenv);   
      ($2, $5, $9, $8)
}
;

statement:   
| { Seq([]) }
| expr ASSIGNMENT expr {
    let rhs = merge_sort (fst $3) (eqsort (snd $1) (snd $3)) in
      match fst $1 with
        | Var _
        | Field _
          -> Assign(fst $1, rhs)
        | _
          -> raise SType_error
  } 
| BEGIN bloc END { $2 }
| IF expr THEN statement { 
    if snd $2 <> Boolean then
      raise SType_error;
    If1(fst $2,$4) 
  }
| IF expr THEN statement ELSE statement { 
    if snd $2 <> Boolean then
      raise SType_error;
    If2(fst $2,$4,$6) 
  }
| WHILE expr DO statement { 
    if snd $2 <> Boolean then
      raise SType_error;
    While(fst $2,$4) 
  }
| NEW LPAREN expr RPAREN {
    (* Only record allocation is allowed *)
    match $3 with
        (Var   _ as expr, (Record _ as et))
      | (Field _ as expr, (Record _ as et))
        -> New (expr, et)
      | _
        -> raise SType_error
  }
| expr { Expr (fst $1) }
;

bloc:
| statement bloc1 { merge_sequences $1 $2 }
;

bloc1:
| { Seq([]) }
| SEMICOLON statement bloc1 { merge_sequences $2 $3 }
;

expr:
| TRUE { 
    (T, Boolean) 
  }
| FALSE { 
    (F, Boolean) 
  }
| INT { 
    (Int $1, Integer)
  }
| IDENT { 
    (Var $1, Types.ident_type $1) 
  } 
| LPAREN expr RPAREN { 
    $2 
  }
| expr PLUS expr { 
    checked_binexpr Plus $1 $3
  }
| expr MINUS expr { 
    checked_binexpr Minus $1 $3
  }
| expr TIMES expr { 
    checked_binexpr Times $1 $3
  }
| expr DIV expr { 
    checked_binexpr Div $1 $3
  }
| expr MOD expr { 
    checked_binexpr Mod $1 $3
  }
| expr LE expr { 
    checked_binexpr Le $1 $3
  }
| expr LEQ expr { 
    checked_binexpr Leq $1 $3
  }
| expr EQ expr { 
    checked_binexpr Eq $1 $3
  }
| expr NEQ expr {
    checked_binexpr Neq $1 $3
  }
| expr GE expr { 
    checked_binexpr Ge $1 $3
  }
| expr GEQ expr { 
    checked_binexpr Geq $1 $3
  }
| expr AND expr { 
    checked_binexpr And $1 $3
  }
| expr OR expr { 
    checked_binexpr Or $1 $3
  }
| NOT expr { 
    checked_unexpr Neg $2
  }
| MINUS expr %prec UMINUS {
    checked_unexpr Uminus $2
  }
| IDENT LPAREN arglist RPAREN { 
    let (fargstype,frettype) = Types.fun_sort $1
    and argstype = List.map snd $3 in
      try
        let args = List.map2 merge_sort (List.map fst $3) (List.map2 eqsort argstype fargstype) in
          (Call ($1, args), frettype)
      with Invalid_argument _ ->
        raise EType_error;
  }
| expr MEMBER IDENT {
    checked_field $1 $3
  }
| NIL {
    (Nil Pointer, Pointer)
  }
;

arglist:
| { [] } 
| expr arglist1 { $1::$2 }   
;

arglist1:
| { [] }
| COMMA arglist { $2 }
;

%%


